home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
AmigActive 2
/
AACD 2.iso
/
AACD
/
Programming
/
fpc
/
compiler
/
tgen68k.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1998-09-24
|
21KB
|
685 lines
{
$Id: tgen68k.pas,v 1.1.1.1.2.4 1998/07/21 12:11:37 carl Exp $
Copyright (c) 1993-98 by Florian Klaempfl, Carl Eric Codere
This unit handles the temporary variables stuff for m68k
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit tgen68k;
interface
uses
cobjects,globals,tree,hcodegen,verbose,files,aasm
{$ifdef m68k}
,m68k
{$endif}
;
type
tregisterset = set of tregister;
tpushed = array[R_D0..R_A6] of boolean;
const
{ D2 to D5 usable as scratch registers }
usablereg32 : byte = 4;
{ A2 to A4 usable as address registers }
usableaddress: byte = 3;
{ FP2 to FP7 usable as FPU registers }
usablefloatreg : byte = 6;
function getregister32 : tregister;
procedure ungetregister32(r : tregister);
{ return a free 32-bit address register }
function getaddressreg: tregister;
procedure ungetregister(r : tregister);
procedure cleartempgen;
{ generates temporary variables }
procedure resettempgen;
procedure setfirsttemp(l : longint);
function gettempsize : longint;
function gettempofsize(size : longint) : longint;
procedure gettempofsizereference(l : longint;var ref : treference);
function istemp(const ref : treference) : boolean;
procedure ungetiftemp(const ref : treference);
function getfloatreg: tregister;
{ returns a free floating point register }
{ used in real, fpu mode, otherwise we }
{ must use standard register allocation }
procedure del_reference(const ref : treference);
procedure del_locref(const location : tlocation);
{ pushs and restores registers }
procedure pushusedregisters(var pushed : tpushed;b : word);
procedure popusedregisters(const pushed : tpushed);
var
unused,usableregs : tregisterset;
c_usableregs : longint;
usedinproc : word;
{ count, how much a register must be pushed if it is used as register }
{ variable }
reg_pushes : array[R_D0..R_A6] of longint;
is_reg_var : array[R_D0..R_A6] of boolean;
implementation
function getusableaddr: byte;
{ Since address registers are different then data registers }
{ we check the unused register list to determine the number }
{ of address registers which are available. }
var
i: byte;
Begin
i:=0;
if R_A2 in unused then
Inc(i);
if R_A3 in unused then
Inc(i);
if R_A4 in unused then
Inc(i);
getusableaddr:=i;
end;
procedure pushusedregisters(var pushed : tpushed;b : word);
var
r : tregister;
begin
{ the following registers can be pushed }
{ D0, D1, D2, D3, D4, D5, D6, D7, A0 }
{ A1, A2, A3, A4 }
for r:=R_D2 to R_A4 do
begin
pushed[r]:=false;
{ if the register is used by the calling subroutine }
if ((b and ($800 shr word(r)))<>0) then
begin
{ and is present in use }
if not(r in unused) then
begin
{ then save it }
{ then save it on the stack }
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,r,R_SPPUSH)));
{ here was a big problem !!!!!}
{ you cannot do that for a register that is
globally assigned to a var
this also means that you must push it much more
often, but there must be a better way
maybe by putting the value back to the stack !! }
if not(is_reg_var[r]) then
unused:=unused+[r];
pushed[r]:=true;
end;
end;
end;
end;
procedure popusedregisters(const pushed : tpushed);
var
r : tregister;
begin
for r:=R_A4 downto R_D2 do
if pushed[r] then
begin
exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SPPULL,r)));
unused:=unused-[r];
end;
end;
procedure ungetregister(r : tregister);
begin
ungetregister32(r)
end;
procedure del_reference(const ref : treference);
begin
if ref.isintvalue then
exit;
ungetregister(ref.base);
ungetregister32(ref.index);
end;
procedure del_locref(const location : tlocation);
begin
if (location.loc<>loc_mem) and (location.loc<>loc_reference) then
exit;
if location.reference.isintvalue then
exit;
ungetregister(location.reference.base);
ungetregister32(location.reference.index);
end;
procedure ungetregister32(r : tregister);
begin
if r in [R_D2,R_D3,R_D4,R_D5,R_D7] then
begin
unused:=unused+[r];
inc(usablereg32);
end
else
if r in [R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7] then
begin
unused:=unused+[r];
inc(usablefloatreg);
end
else
if r in [R_A2,R_A3,R_A4] then
begin
unused:=unused+[r];
inc(usableaddress);
end;
{ other registers are RESERVED and should not be freed }
end;
function getfloatreg: tregister;
{ returns a free floating point register }
{ used in real, fpu mode, otherwise we }
{ must use standard register allocation }
var
i:tregister;
begin
dec(usablefloatreg);
if usablefloatreg = 0 then
Message(cg_f_internal_error_in_getfloatreg);
for i:=R_FP2 to R_FP7 do
begin
if i in unused then
begin
unused := unused-[i];
getfloatreg := i;
exit;
end;
end;
{ if we are here, then there was an allocation failure }
Message(cg_f_internal_error_in_getfloatreg);
end;
function getaddressreg: tregister;
begin
dec(usableaddress);
if R_A2 in unused then
begin
unused:=unused-[R_A2];
usedinproc:=usedinproc or ($800 shr word(R_A2));
getaddressreg:=R_A2;
end
else
if R_A3 in unused then
begin
unused:=unused-[R_A3];
usedinproc:=usedinproc or ($800 shr word(R_A3));
getaddressreg:=R_A3;
end
else
if R_A4 in unused then
begin
unused:=unused-[R_A4];
usedinproc:=usedinproc or ($800 shr word(R_A4));
getaddressreg:=R_A4;
end
else
begin
internalerror(10);
end;
end;
function getregister32 : tregister;
begin
dec(usablereg32);
if R_D2 in unused then
begin
unused:=unused-[R_D2];
usedinproc:=usedinproc or ($800 shr word(R_D2));
getregister32:=R_D2;
end
else if R_D3 in unused then
begin
unused:=unused-[R_D3];
usedinproc:=usedinproc or ($800 shr word(R_D3));
getregister32:=R_D3;
end
else if R_D4 in unused then
begin
unused:=unused-[R_D4];
usedinproc:=usedinproc or ($800 shr word(R_D4));
getregister32:=R_D4;
end
else if R_D5 in unused then
begin
unused:=unused-[R_D5];
usedinproc:=usedinproc or ($800 shr word(R_D5));
getregister32:=R_D5;
end
else if R_D7 in unused then
begin
unused:=unused-[R_D7];
usedinproc:=usedinproc or ($800 shr word(R_D7));
getregister32:=R_D7;
end
else
begin
internalerror(10);
end;
end;
procedure cleartempgen;
begin
unused:=usableregs;
usablereg32:=c_usableregs;
usableaddress:=getusableaddr;
end;
type
pfreerecord = ^tfreerecord;
tfreerecord = record
next : pfreerecord;
pos : longint;
size : longint;
{$ifdef EXTDEBUG}
line : longint;
{$endif}
end;
var
tmpfreelist : pfreerecord;
templist : pfreerecord;
lastoccupied : longint;
firsttemp, maxtemp : longint;
procedure resettempgen;
var
hp : pfreerecord;
begin
while assigned(tmpfreelist) do
begin
hp:=tmpfreelist;
tmpfreelist:=hp^.next;
dispose(hp);
end;
while assigned(templist) do
begin
{$ifdef EXTDEBUG}
Comment(V_Warning,'temporary assignment of size '
+tostr(templist^.size)+' from '+tostr(templist^.line)+
+' at pos '+tostr(templist^.pos)+
' not freed at the end of the procedure');
{$endif}
hp:=templist;
templist:=hp^.next;
{$ifndef EXTDEBUG}
dispose(hp);
{$endif not EXTDEBUG}
end;
templist:=nil;
tmpfreelist:=nil;
firsttemp:=0;
maxtemp:=0;
lastoccupied:=0;
end;
procedure setfirsttemp(l : longint);
begin
{ this is a negative value normally }
if l < 0 then
Begin
if odd(l) then
Dec(l);
end
else
Begin
if odd(l) then
Inc(l);
end;
firsttemp:=l;
maxtemp := l;
lastoccupied:=l;
end;
function gettempofsize(size : longint) : longint;
var
last,hp : pfreerecord;
begin
{ this code comes from the heap management of FPC ... }
if (size mod 4)<>0 then
size:=size+(4-(size mod 4));
if assigned(tmpfreelist) then
begin
last:=nil;
hp:=tmpfreelist;
while assigned(hp) do
begin
{ first fit }
if hp^.size>=size then
begin
gettempofsize:=hp^.pos;
if hp^.pos-size < maxtemp then
maxtemp := hp^.size-size;
{ the whole block is needed ? }
if hp^.size>size then
begin
hp^.size:=hp^.size-size;
hp^.pos:=hp^.pos-size;
end
else
begin
if assigned(last) then
last^.next:=hp^.next
else
tmpfreelist:=nil;
dispose(hp);
end;
exit;
end;
last:=hp;
hp:=hp^.next;
end;
end;
{ nothing free is big enough : expand temp }
gettempofsize:=lastoccupied-size;
lastoccupied:=lastoccupied-size;
if lastoccupied < maxtemp then
maxtemp := lastoccupied;
end;
function gettempsize : longint;
begin
{ we only push words and we want to stay on }
{ even stack addresses }
{ maxtemp is negative }
if (maxtemp mod 2)<>0 then
dec(maxtemp);
gettempsize:=-maxtemp;
end;
procedure gettempofsizereference(l : longint;var ref : treference);
var
tl : pfreerecord;
begin
{ do a reset, because the reference isn't used }
reset_reference(ref);
ref.offset:=gettempofsize(l);
ref.base:=procinfo.framepointer;
new(tl);
tl^.pos:=ref.offset;
tl^.size:=l;
tl^.next:=templist;
templist:=tl;
{$ifdef EXTDEBUG}
tl^.line:=current_module^.current_inputfile^.line_no;
{$endif}
end;
function istemp(const ref : treference) : boolean;
begin
istemp:=((ref.base=procinfo.framepointer) and
(ref.offset<firsttemp));
end;
procedure ungettemp(pos : longint;size : longint);
var
hp,newhp : pfreerecord;
begin
if (size mod 4)<>0 then
size:=size+(4-(size mod 4));
if size = 0 then
exit;
if pos<=lastoccupied then
if pos=lastoccupied then
begin
lastoccupied:=pos+size;
hp:=tmpfreelist;
newhp:=nil;
while assigned(hp) do
begin
{ conneting a free block }
if hp^.pos=lastoccupied then
begin
if assigned(newhp) then newhp^.next:=nil
else tmpfreelist:=nil;
lastoccupied:=lastoccupied+hp^.size;
dispose(hp);
break;
end;
newhp:=hp;
hp:=hp^.next;
end;
end
else
begin
{$ifdef EXTDEBUG}
Comment(V_Warning,'temp managment problem : ungettemp() pos < lastoccupied !');
{$endif}
end
else
begin
new(newhp);
{ size can be allways set }
newhp^.size:=size;
newhp^.pos := pos;
{ if there is no free list }
if not assigned(tmpfreelist) then
begin
{ then generate one }
tmpfreelist:=newhp;
newhp^.next:=nil;
exit;
end;
{ search the position to insert }
hp:=tmpfreelist;
while assigned(hp) do
begin
{ conneting two blocks ? }
if hp^.pos+hp^.size=pos then
begin
inc(hp^.size,size);
dispose(newhp);
break;
end
{ if the end is reached, then concat }
else if hp^.next=nil then
begin
hp^.next:=newhp;
newhp^.next:=nil;
break;
end
{ falls der nchste Zeiger gráer ist, dann }
{ Einhngen }
else if hp^.next^.pos<=pos+size then
begin
{ concat two blocks ? }
if pos+size=hp^.next^.pos then
begin
newhp^.next:=hp^.next^.next;
inc(newhp^.size,hp^.next^.size);
dispose(hp^.next);
hp^.next:=newhp;
end
else
begin
newhp^.next:=hp^.next;
hp^.next:=newhp;
end;
break;
end;
hp:=hp^.next;
end;
end;
end;
procedure ungetiftemp(const ref : treference);
var
tl,prev : pfreerecord;
begin
if istemp(ref) then
begin
prev:=nil;
tl:=templist;
while assigned(tl) do
begin
if ref.offset=tl^.pos then
begin
ungettemp(ref.offset,tl^.size);
if assigned(prev) then
prev^.next:=tl^.next
else
templist:=tl^.next;
dispose(tl);
exit;
end
else
begin
prev:=tl;
tl:=tl^.next;
end;
end;
{$ifdef EXTDEBUG}
Comment(V_Warning,'Internal: temp managment problem : '+
'temp not found for release at offset '+tostr(ref.offset));
{$endIf}
end;
end;
begin
{ contains both information on Address registers and data registers }
{ even if they are allocated separately. }
usableregs:=[R_D0,R_D1,R_D2,R_D3,R_D4,R_D5,R_D6,R_D7,R_A0,R_A1,R_A2,R_A3,R_A4,
R_FP0,R_FP1,R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7];
c_usableregs:=4;
tmpfreelist:=nil;
templist:=nil;
end.
{
$Log: tgen68k.pas,v $
Revision 1.1.1.1.2.4 1998/07/21 12:11:37 carl
* cleartempgen , also clears the address register count
* ungetregister was not checking what type of register trying to free
Revision 1.1.1.1 1998/03/25 11:18:15 root
* Restored version
Revision 1.12 1998/03/22 12:45:38 florian
* changes of Carl-Eric to m68k target commit:
- wrong nodes because of the new string cg in intel, I had to create
this under m68k also ... had to work it out to fix potential alignment
problems --> this removes the crash of the m68k compiler.
- added absolute addressing in m68k assembler (required for Amiga startup)
- fixed alignment problems (because of byte return values, alignment
would not be always valid) -- is this ok if i change the offset if odd in
setfirsttemp ?? -- it seems ok...
Revision 1.11 1998/03/10 04:21:15 carl
* fixed extdebug problems
Revision 1.10 1998/03/10 01:17:30 peter
* all files have the same header
* messages are fully implemented, EXTDEBUG uses Comment()
+ AG... files for the Assembler generation
Revision 1.9 1998/03/06 00:53:00 peter
* replaced all old messages from errore.msg, only ExtDebug and some
Comment() calls are left
* fixed options.pas
Revision 1.8 1998/03/02 01:49:35 peter
* renamed target_DOS to target_GO32V1
+ new verbose system, merged old errors and verbose units into one new
verbose.pas, so errors.pas is obsolete
Revision 1.7 1998/02/13 10:35:51 daniel
* Made Motorola version compilable.
* Fixed optimizer
Revision 1.6 1998/01/11 03:40:16 carl
+ added fpu register allocation
Revision 1.3 1997/12/09 14:13:07 carl
* bugfix of free register list.
Revision 1.2 1997/11/28 18:14:49 pierre
working version with several bug fixes
Revision 1.1.1.1 1997/11/27 08:33:03 michael
FPC Compiler CVS start
Pre-CVS log:
+ feature added
- removed
* bug fixed or changed
History (started with version 0.9.0):
7th december 1996:
* some code from Pierre Muller inserted
makes the use of the stack more efficient
5th september 1997:
+ Converted for Motorola MC68000 output (C. E. Codere)
24nd september 1997:
+ Reserved register list modified. (CEC)
26 september 1997:
+ Converted to work with v093 (CEC)
* Knowing that base is in address register, modified routines
accordingly. (CEC)
27 september 1997:
+ pushusedregisters now pushes only non-scratch registers.
2nd october 1997:
+ added strict error checking when extdebug defined.
23 october 1997:
- it seems that sp, and the base pointer can be freed in ungetregister,
removed warning accordingly. (CEC).
* bugfix of address register in usableregs set. (They were not defined...) (CEC).
* other stupid bug! When I changed the register conventions, I forgot to change
getaddressreg to reflect those changes!! (CEC).
}
